EnigmA Amiga Run 1997 February

home *** CD-ROM | disk | FTP | other *** search

/ EnigmA Amiga Run 1997 February / EnigmA AMIGA RUN 15 (1997)(G.R. Edizioni)(IT)[!][issue 1997-02][PLANET CD V].iso / enigma / earcd / varie / rpn_calc.lha / rpn_calc / RPN_Calc.bas < prev next >

Wrap

BASIC Source File | 1994-03-22 | 15KB | 1,026 lines

REM $option y+,k25 'window defeat, no icon ,larger heap REM $option b- 'break check off ON ERROR GOTO errhandler ON BREAK GOSUB brkhandler CALL menuinit ON MENU GOSUB menuhandler MENU ON BREAK ON RANDOMIZE TIMER 't[1-9] = temporary float vars 's[1-9] = temporary int vars 't[1-9]$ = temp. strings 'i,j =loop variables 'pl,pp () = play vars 'rc,rcount () =repeat vars 'rptcnt,plng =rpt/play nesting 'cond,eos,play,rpt,none,norm,chk = boolean 'sp = string pos. 'i$,a$ = input strings 'a,b =calc vars DEFINT i,j,p,r,f DEFINT c,e,s,n,o DEFDBL g,h,v,t,a,b CONST plydepth=20 CONST rptdepth=20 CONST reclevels=40 CONST stacksize=100 CONST strue=-1 CONST false=0 DIM SHARED vars(25) DIM SHARED rec$(25,reclevels) DIM SHARED heap(stacksize) DIM SHARED pl(plydepth),pp(plydepth) DIM SHARED rc(rptdepth),rcount(rptdepth) DIM SHARED q$(rptdepth) DIM SHARED silent,offset,cond DIM SHARED eos,sp,play,rpt DIM SHARED plng,rptcnt DIM SHARED cond,a$,sep$,i$,sp DIM SHARED ws$ pi#=3.14159265358979324 e#=2.71828182845904524 trig=1 DECLARE FUNCTION gettop() DECLARE FUNCTION getstack() DECLARE FUNCTION getword$() DECLARE FUNCTION chknum() DECLARE FUNCTION getnum() DECLARE FUNCTION getletter() WINDOW 1,"RPN_Calc",,31 FOR i=0 TO 25 rec$(i,1)="q" vars(i)=0 NEXT ws$=" "+CHR$(9)+"," offset=0 cond=false play=false rpt=false a$="" sep$=" Result: " WHILE strue getln: PRINT offset+1; INPUT ": ",i$ IF i$="" THEN GOTO getln: END IF com: eos=false:sp=1 WHILE NOT eos a$=getword$() a$=LCASE$(a$) SELECT CASE a$ CASE "help","info" GOSUB help: CASE "getval","getvalue" s=gettop() IF s<=offset THEN t=getstack(s) strout sep$ numout t newline ELSE strout sep$+"NULL" newline END IF CASE "swap" t1=gettop() t2=gettop() putstack t1 putstack t2 CASE "gettop" t=gettop() putstack t strout sep$ numout t newline CASE "dupl","duplicate" t=gettop() putstack t putstack t CASE "?","lookstack" s=getnum()-1 IF s<offset AND s=>0 THEN t=getstack(s) strout sep$ numout t newline ELSE strout sep$+"NULL" newline END IF CASE "curpos" s=offset putstack s strout sep$ numout s newline CASE "back" IF offset>0 THEN offset=offset-1 CASE "%","setoffset" s=getnum()-1 IF s<=offset AND s>=0 THEN offset=s CASE "#","getstack" s=getnum()-1 IF s<=offset AND s>0 THEN t=getstack(s) strout sep$ numout t newline putstack t ELSE PRINT sep$;"NULL" END IF CASE "plot" t2=gettop() t1=gettop() PSET(WINDOW(2)/2+t1,WINDOW(3)/2-t2) CASE "winwi","windowwidth" putstack WINDOW(2)/2 CASE "winhi","windowheigth" putstack WINDOW(3)/2 CASE "locate","setcursorpos" t1=gettop() t2=gettop() LOCATE t2,t1 CASE "getnum","inputnum" INPUT "",t putstack t CASE "$","getvar" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE putstack vars(s) strout sep$ numout vars(s) newline END IF CASE "set","setvar" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE t=gettop() vars(s)=t putstack t END IF CASE "get","lookvar" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE t=gettop() vars(s)=t END IF CASE "saveall" INPUT "Filename : ",f$ OPEN f$ FOR OUTPUT AS 1 FOR i=0 TO 25 FOR g=j TO reclevels t$=rec$(i,j) PRINT #1,t$ IF t$="q" THEN EXIT FOR END IF NEXT NEXT CLOSE 1 CASE "loadall" INPUT "Filename : ",f$ IF NOT FEXISTS(f$) THEN PRINT "Can't find ";f$ ELSE OPEN f$ FOR INPUT AS 1 FOR i=0 TO 25 FOR j=1 TO reclevels INPUT #1,t$ rec$(i,j)=t$ IF temp$="q" THEN EXIT FOR END IF NEXT NEXT CLOSE 1 END IF CASE "save" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE INPUT "Filename : ",f$ OPEN f$ FOR OUTPUT AS 1 FOR i=1 TO reclevels t$=rec$(s,i) PRINT #1,t$ IF t$="q" THEN EXIT FOR END IF NEXT CLOSE 1 END IF CASE "load" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE INPUT "Filename : ",f$ IF NOT FEXISTS(f$) THEN PRINT "Can't find ";f$ ELSE OPEN f$ FOR INPUT AS 1 FOR i=1 TO reclevels INPUT #1,t$ rec$(s,i)=t$ IF t$="q" THEN EXIT FOR END IF NEXT CLOSE 1 END IF END IF CASE "'","print" PRINT getword$ CASE "rep","repeat" 'should be a recursive SUB-prog. instead INCR rptcnt rcount(rptcnt)=getnum() IF NOT play THEN INPUT "Command : ",q$(rptcnt) ELSE INCR pl(plng) q$(rptcnt)=rec$(pp(plng),pl(plng)) END IF rpt=strue rc(rptcnt)=1 WHILE rc(rptcnt)<=rcount(rptcnt) 'no arrays in FOR..NEXT loops i$=q$(rptcnt) GOSUB com INCR rc(rptcnt) WEND DECR rptcnt IF rptcnt=0 rpt=false END IF CASE "clr","clearall","reset" trig=1 cond=false play=false rpt=false silent=false offset=0 rptcnt=0 plng=0 FOR i=0 TO 25 vars(i)=0 rec$(i,1)="q" NEXT CLS CASE "cls","clearscreen" CLS CASE "rec","record" s=getletter() IF s<0 THEN PRINT "Bad args" ELSE FOR i=1 TO reclevels INPUT "Record: ",rec$(s,i) IF rec$(s,i)="q" OR rec$(s,i)="quit" THEN EXIT FOR NEXT END IF CASE "play" INCR plng pp(plng)=getletter() IF pp(plng)<0 THEN PRINT "Bad args" ELSE play=strue pl(plng)=1 WHILE pl(plng)<=reclevels i$=rec$(pp(plng),pl(plng)) IF i$="q" OR i$="quit" THEN i$="" EXIT WHILE END IF GOSUB com INCR pl(plng) WEND END IF DECR plng IF plng=0 THEN play=false END IF CASE "texton" silent=false CASE "textoff" silent=strue CASE "goto" s=getnum() IF play THEN pl(plng)=s-1 END IF CASE "gotop" s=gettop() IF play THEN pl(plng)=s-1 END IF CASE "gocon" s=getnum() IF play AND cond THEN pl(plng)=s-1 cond=false END IF CASE "gotopcon" s=gettop() IF play AND cond THEN pl(plng)=s-1 cond=false END IF CASE "rvscon","change_condition" IF cond THEN cond=false ELSE cond=strue END IF CASE "checkcon" printcon CASE "deg","degrees" trig=pi#/180 CASE "rad","radians" trig=1 CASE "gra","gradians" trig=pi#/200 CASE "pi" putstack pi# CASE "e" putstack e# CASE "rnd","random" t=RND putstack t printres t CASE "q","quit" WINDOW CLOSE 1 SYSTEM CASE ELSE GOSUB calc END SELECT WEND IF play THEN RETURN IF rpt THEN RETURN WEND calc: norm=strue chk=false none=false SELECT CASE offset CASE 0 a=0 b=0 none=strue norm=false CASE 1 a=gettop() b=0 norm=false CASE ELSE a=gettop() b=gettop() END SELECT SELECT CASE a$ CASE "not","~" a=NOT a CASE "neg" a=-a CASE "exp" a=EXP(a) CASE "ln" a=LOG(a) CASE "lg" a=LOG10(a) CASE "sin" a=SIN(a*trig) CASE "cos" a=COS(a*trig) CASE "tan" a=TAN(a*trig) CASE "cot","cotan" a=1/TAN(a*trig) CASE "atn","arctan" a=ATN(a)/trig CASE "acot","arccot" a=(1/ATN(a))/trig CASE "asin","arcsin" a=ATN(a/SQR(-a*a+1))/trig CASE "acos","arccos" a=(-ATN(a/SQR(-a*a+1))+pi/2)/trig CASE "sinh" a=((EXP(a)-EXP(-a))/2)/trig CASE "cosh" a=((EXP(a)+EXP(-a))/2)/trig CASE "tanh" a=((EXP(-a)/EXP(a)+EXP(-a))*2+1)/trig CASE "coth" a=(EXP(-a)/(EXP(a)-EXP(-a))*2+1)/trig CASE "abs" a=ABS(a) CASE "sqrt","root","squareroot" a=SQR(a) CASE "sqr","square" a=a*a CASE "cube" a=a*a*a CASE "int" a=INT(a+0.5) CASE "trunc" a=INT(a) CASE "frac" a=a-INT(a) CASE "fac","faculty" t=1 FOR i=1 TO a t=t*g NEXT a=t CASE "+","plus" a=a+b norm=false CASE "-","minus" a=a-b norm=false CASE "*" a=a*b norm=false CASE "/" a=a/b norm=false CASE "^","pow","power" a=a^b norm=false CASE "<<","leftshift","shiftleft" a=a*2^b norm=false CASE ">>","rightshift","shiftright" a=a*.5^b norm=false CASE "mod","modulus" a=a MOD b norm=false CASE "|","!","or" a=a OR b norm=false CASE "&","and" a=a AND b norm=false CASE "xor" a=a XOR b norm=false CASE "<","less_than" IF a<b THEN cond=strue ELSE cond=false chk=strue printcon CASE ">","greater_than" IF a>b THEN cond=strue ELSE cond=false chk=strue printcon CASE "=","equal" IF a=b THEN cond=strue ELSE cond=false chk=strue printcon CASE "<=","=<","less_or_equal" IF a<=b THEN cond=strue ELSE cond=false chk=strue printcon CASE ">=","=>","greater_or_equal" IF a>=b THEN cond=strue ELSE cond=false chk=strue printcon CASE "<>","notequal" IF a<>b THEN cond=strue ELSE cond=false chk=strue printcon CASE ELSE IF norm THEN putstack b putstack a ELSEIF NOT none THEN putstack a END IF IF chknum(a$) THEN putstack VAL(a$) ELSE PRINT "Syntax error" END IF RETURN END SELECT IF norm THEN putstack b END IF putstack a IF NOT chk THEN printres a END IF RETURN SUB menuinit MENU 1,0,1,"Project" MENU 1,1,1,"Quit" END SUB SUB printres (VAL t) strout sep$ numout t newline END SUB SUB printcon IF NOT cond THEN strout sep$+"FALSE" newline ELSE strout sep$+"strue" newline END IF END SUB SUB strout (t$) IF NOT silent THEN PRINT t$; END IF END SUB SUB numout (VAL t) IF NOT silent THEN PRINT t; END IF END SUB SUB newline IF NOT silent THEN PRINT END IF END SUB SUB putstack (VAL t) IF offset=stacksize THEN EXIT SUB END IF heap(offset)=t INCR offset END SUB FUNCTION gettop() IF offset=0 THEN gettop=0 EXIT FUNCTION END IF DECR offset gettop=heap(offset) END FUNCTION FUNCTION getstack(VAL t) IF t<0 OR t>=offset THEN getstack=0 EXIT FUNCTION END IF getstack=heap(t) END FUNCTION FUNCTION getword$() STATIC l,eow,sow,t1$,t2$ eow=false:sow=false l=LEN(i$) t1$="" WHILE sp<l+1 AND NOT sow t2$=MID$(i$,sp,1) IF INSTR(ws$,t2$)<>0 THEN INCR sp ELSE sow=strue END IF WEND WHILE sp<l+1 AND NOT eow t2$=MID$(i$,sp,1) IF INSTR(ws$,t2$)<>0 THEN eow=strue ELSE t1$=t1$+t2$ END IF INCR sp WEND IF sp=l+1 THEN eos=strue getword$=t1$ END FUNCTION FUNCTION chknum (t1$) STATIC i,t2$ chknum=strue FOR i=1 TO LEN(t1$) t2$=MID$(t1$,i,1) SELECT CASE t2$ CASE "e","d" IF i=1 THEN chknum=false EXIT FUNCTION ELSE EXIT SELECT END IF CASE ".","+","-" EXIT SELECT CASE <"0",>"9" chknum=false EXIT FUNCTION END SELECT NEXT END FUNCTION FUNCTION getnum() STATIC t$ t$=getword$() IF chknum(t$) THEN getnum=VAL(t$) ELSE ERROR 5 END IF END FUNCTION FUNCTION getletter() STATIC t,t$ t$=getword$() t=ASC(LEFT$(t$,1))-ASC("a") IF LEN(t$)<>1 OR t<0 OR t>25 THEN getletter=-1 ELSE getletter=t END IF END FUNCTION errhandler: ern=ERR IF ern=11 THEN PRINT "Division by zero" i$="0" ON ERROR GOTO errhandler RESUME getln: ELSEIF ern=6 THEN PRINT "Overflow" a$="1.79769313486e308" ON ERROR GOTO errhandler RESUME com: ELSEIF ern=5 THEN PRINT "Illegal args" i$="0" ON ERROR GOTO errhandler RESUME getln: ELSE ON ERROR GOTO 0 END IF brkhandler: rc(plng)=rcount(plng)+1 pl(plng)=reclevels+1 RETURN menuhandler: menunum=MENU(0) menuitem=MENU(1) SELECT CASE menunum CASE 0 RETURN CASE 1 SELECT CASE menuitem CASE 1 SYSTEM END SELECT END SELECT RETURN help: t$=LCASE$(getword$()) SELECT CASE t$ CASE "help","info" PRINT "[help ,info]" PRINT "This command gives you info about the specified" PRINT "command/operation." CASE "getval","getvalue" PRINT "[getval ,getvalue]" PRINT "This command prints out the contents of the cell whose" PRINT "number is specified by the contents of the top cell." CASE "swap" PRINT "[swap]" PRINT "This command swaps the contents of the two top cells." CASE "gettop" PRINT "[gettop]" PRINT "This command prints the contents of the top cell." CASE "dupl","duplicate" PRINT "[dupl ,duplicate]" PRINT "This command puts a new copy of the contents of the top cell" PRINT "onto the stack." CASE "?","lookstack" PRINT "[? ,lookstack]" PRINT "This command prints out the contents of the specified cell." CASE "currentpos" PRINT "[currentpos]" PRINT "This command puts the current stack position on the top of" PRINT "the stack." CASE "back" PRINT "[back]" PRINT "This command decrements the stack position by 1, thus erasing" PRINT "the contents of the top cell." CASE "%","setoffset" PRINT "[% ,setoffset]" PRINT "This command sets the stack position to the specified number" PRINT "if it is less than the current position." CASE "#","getstack" PRINT "[# ,getstack]" PRINT "This command puts the contents of the specified cell on top" PRINT "of the stack." CASE "plot" PRINT "[plot]" PRINT "This command sets a pixel. The x-coordinate is taken from the" PRINT "top of the stack and the y-coordinate from the next cell." CASE "winwi","windowwidth" PRINT "[winwi ,windowwidth]" PRINT "This command puts the width (in pixels) of the output window" PRINT "on the top of the stack." CASE "winhi","windowheight" PRINT "[winhi ,windowheight]" PRINT "This command puts the height (in pixels) of the output window" PRINT "on the top of the stack." CASE "locate","setcursorpos" PRINT "[locate ,setcursorpos]" PRINT "This command move the cursor to the x-y coordinate specified" PRINT "by the two top stack positions respectively." CASE "getnum","inputnum" PRINT "[getnum ,inputnum]" PRINT "This command reads a number from the keyboard and puts it" PRINT "on the top of the stack." CASE "$","getvar" PRINT "[$ ,getvar]" PRINT "This function takes the value of the specified variable and" PRINT "puts it on the stack." CASE "set","setvar" PRINT "[set ,setvar]" PRINT "This command sets the specified variable to the value located" PRINT "at the top of the stack witout disrupting the stack." CASE "get","lookvar" PRINT "[get ,lookvar]" PRINT "This command pulls a number from the top of the stack and" PRINT "assigns it to the specified variable." CASE "saveall" PRINT "[saveall]" PRINT "Prompts for a filename and saves all programs to that file." CASE "loadall" PRINT "[loadall]" PRINT "Prompts for a filename and loads all programs from that file." PRINT "Each program is terminated by a 'q'." CASE "save" PRINT "[save]" PRINT "Prompts for filename and saves the specified program (a-z)" PRINT "to that file." CASE "load" PRINT "[load]" PRINT "Asks for a filename and loads the specified program from" PRINT "that file." CASE "'","print" PRINT "[' ,print]" PRINT "Puts the supplied word on the screen." CASE "rep","repeat" PRINT "[rep ,repeat]" PRINT "Repeats a command for the supplied number of times." CASE "clr","clearall","reset" PRINT "[clr ,clearall ,reset]" PRINT "Clears all programs ,sets all variables to zero and resets" PRINT "everything else to the state it was at from the start." CASE "cls","clearscreen" PRINT "[cls ,clearscreen]" PRINT "Clears the screen." CASE ELSE PRINT "Unknown command/function." END SELECT RETURN